home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / sendun1a / calendar.cls < prev    next >
Text File  |  1999-10-15  |  4KB  |  136 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = 0   'False
  4. END
  5. Attribute VB_Name = "CSysMonthCal32"
  6. Attribute VB_GlobalNameSpace = False
  7. Attribute VB_Creatable = True
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = False
  10. Option Explicit
  11.  
  12. Private Type tagInitCommonControlsEx
  13.     lngSize As Long
  14.     lngICC As Long
  15. End Type
  16.  
  17. Private Const ICC_DATE_CLASSES = &H100&
  18.  
  19. Private Declare Function InitCommonControlsEx Lib "Comctl32.dll" (iccex As tagInitCommonControlsEx) As Boolean
  20.  
  21. Private Const MONTHCAL_CLASSA = "SysMonthCal32"
  22.  
  23. Private Const H_MAX As Long = &HFFFF + 1
  24. Private Const DTM_FIRST = &H1000
  25. Private Const DTN_FIRST = (H_MAX - 760&)
  26. Private Const DTN_LAST = (H_MAX - 799&)
  27. Private Const MCM_FIRST = &H1000
  28. Private Const MCM_HITTEST = (MCM_FIRST + 14)
  29. Private Const MCN_FIRST = (H_MAX - 750&)
  30. Private Const MCN_LAST = (H_MAX - 759&)
  31. Private Const MCM_SETRANGE = (MCM_FIRST + 18)
  32. Private Const MCN_SELECT = (MCN_FIRST + 4)
  33. Private Const MCM_GETCURSEL = (MCM_FIRST + 1)
  34. Private Const MCM_GETTODAY = (MCM_FIRST + 13)
  35.  
  36. Private Const SW_HIDE = 0
  37. Private Const SW_SHOWNORMAL = 1
  38.  
  39. Private Type SYSTEMTIME
  40.         wYear As Integer
  41.         wMonth As Integer
  42.         wDayOfWeek As Integer
  43.         wDay As Integer
  44.         wHour As Integer
  45.         wMinute As Integer
  46.         wSecond As Integer
  47.         wMilliseconds As Integer
  48. End Type
  49.  
  50. Private Const WS_VISIBLE = &H10000000
  51. Private Const WS_CHILD = &H40000000
  52.  
  53. Private Declare Function SendStringMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
  54. Private Declare Function CreateWindowEX Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
  55. Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
  56. Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
  57. Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
  58. Private Declare Function MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
  59. Private Declare Function IsWindowVisible Lib "user32" (ByVal hWnd As Long) As Long
  60.  
  61. Private Const DTN_DATETIMECHANGE = (DTN_FIRST + 1)
  62.   
  63. Private MonthCalHwnd As Long
  64. Private MonthCalParent As Object
  65. Public Property Get hWnd() As Long
  66.     
  67.     hWnd = MonthCalHwnd
  68.     
  69. End Property
  70. Public Function Create( _
  71.     Optional Left As Integer = 0, _
  72.         Optional Top As Integer = 0, _
  73.             Optional Width As Integer = 200, _
  74.                 Optional Height As Integer = 160) _
  75.                     As Boolean
  76.     
  77.     If Parent Is Nothing Then
  78.         Create = False
  79.         Exit Function
  80.     End If
  81.     
  82.     MonthCalHwnd = CreateWindowEX(0, "SysMonthCal32", "", _
  83.         WS_CHILD Or WS_VISIBLE, 0, 0, 0, 0, _
  84.             Parent.hWnd, 0, App.hInstance, 0)
  85.    
  86.     Call ShowWindow(hWnd, SW_SHOWNORMAL)
  87.     
  88.     Call MoveWindow(MonthCalHwnd, Left, Top, Width, Height, True)
  89.      
  90. End Function
  91. Public Property Set Parent(frm As Object)
  92.     
  93.     Set MonthCalParent = frm
  94.     
  95. End Property
  96. Public Property Get Parent() As Object
  97.     
  98.     Set Parent = MonthCalParent
  99.     
  100. End Property
  101. Private Sub Class_Initialize()
  102.     
  103.     Dim iccex As tagInitCommonControlsEx
  104.     
  105.     With iccex
  106.         .lngSize = LenB(iccex)
  107.         .lngICC = ICC_DATE_CLASSES
  108.     End With
  109.     
  110.     Call InitCommonControlsEx(iccex)
  111.     
  112.     MonthCalHwnd = 0
  113.     
  114. End Sub
  115. Private Sub Class_Terminate()
  116.     
  117.     If MonthCalHwnd <> 0 Then
  118.         Call DestroyWindow(MonthCalHwnd)
  119.     End If
  120.     
  121. End Sub
  122.  Public Function GetCalendarDate() As Date
  123.     
  124.     Dim systime As SYSTEMTIME
  125.     Dim CalDate As Date
  126.    
  127.     Call SendMessage(MonthCalHwnd, MCM_GETCURSEL, 0, systime)
  128.   
  129.     With systime
  130.         CalDate = DateSerial(.wYear, .wMonth, .wDay)
  131.     End With
  132.     
  133.     GetCalendarDate = CalDate
  134.     
  135. End Function
  136.